Pascal Super Library/Pascal Super Library (CW International)(1997).bin/LIBRARY/PBLIB1/UNITS/OBJSTRA.INC

Text File | 1994-04-30 | 14KB | 562 lines

{SECTION STR_object }
Procedure STR_object.init;
var  nbytes: Word;
     st : string[1];
     begin
     GetMem (strptr, 1);
     st := '';
     Move (st, strptr^, 1);
     end;


procedure STR_object.dispose;
var  nbytes: Word;
      begin
      IF strptr <> NIL then
          begin
          nbytes := Length(strptr^) + 1;
          FreeMem (strptr, nbytes);
          strptr := NIL;
          end;
      end;


Function STR_object.store (st: String): boolean;
var  nbytes: Word;
     begin
     if strptr <> NIL then dispose;
     nbytes := Length (st) + 1;
     IF MaxAvail < nbytes then  store := False
     else begin
          GetMem (strptr, nbytes);
          Move (st, strptr^, nbytes);
          store := True;
          end;
      end;


Function STR_object.fetch: String;
      begin
      IF strptr = NIL then
           fetch := ''
      ELSE fetch := strptr^;
      end;


Procedure STR_object.dump;
      begin
      writeln('STR_object dump: ','{',seg(strptr):5,':',ofs(strptr):4,'}',
                '   ',length(strptr^),'  ',strptr^);
      end;



{SECTION STRA_object }
Procedure STRA_object.init(max : integer);
var l : longint;
    i : integer;
     begin
     arrayptr    := NIL;
     arraymax    := 0;
     arrayused   := 0;
     arraysorted := true;
     l := sizeof(STR_object) * max;
     if memavail > l then
          begin
          getmem(arrayptr,l);
          arraymax := max;
          arrayused := 0;
          for i := 1 to arraymax do arrayptr^[i].init;
          modified    := false;
          end;
     end;


procedure STRA_object.done;
var l : longint;
    i : integer;
    ok : boolean;
     begin
     l := sizeof(STR_object) * arraymax;
     IF (arrayptr <> NIL) and (l > 0) then
          begin
          for i := 1 to arraymax do arrayptr^[i].dispose;
          FreeMem (arrayptr,l);
          arrayptr := NIL;
          end;
     arrayused := 0;
     arraysorted := false;
     end;



Procedure STRA_object.clear;
var i  : integer;
    ok : boolean;
     begin
     if arrayused < 1 then exit;
     if arrayptr <> NIL then
          begin
          for i := 1 to arrayused do ok := arrayptr^[i].store('');
          arrayused := 0;
          modified  := false;
          end;
     end;


Function  STRA_object.Count : integer;
     begin
     Count := arrayused;
     end;


Function  STRA_object.sorted : boolean;
     begin
     sorted := arraysorted;
     end;


Function  STRA_object.ArrayMaxSize : integer;
     begin
     ArrayMaxSize := arraymax;
     end;


Function STRA_object.append(st : string) : boolean;
var OK : boolean;
     begin
     OK := false;
     if (arrayused < arraymax) and (MaxAvail > (length(st)+10)) then
          begin
          inc(arrayused);
          OK := arrayptr^[arrayused].Store(st);
          arraysorted := false;
          modified    := true;
          end;
     append := OK;
     end;



Function STRA_object.appendpush(st : string) : boolean;
var OK : boolean;
     begin
     OK := true;
     if (arrayused = arraymax) then ok := deletestr(1);
     if OK then OK := STRA_object.storeN(arraymax,st);
     appendpush := OK;
     end;



Function STRA_object.storeN (n : integer; st : string): boolean;
var OK : boolean;
     begin
     OK := false;
     if (n > 0) and (n <= arraymax) and (MaxAvail > (length(st)+10)) then
          begin
          if n > arrayused then arrayused := n;
          OK := arrayptr^[n].Store(st);
          modified    := true;
          arraysorted := false;
          end;
     storeN := OK;
     end;


Function STRA_object.fetchN(n : integer) : string;
var s : string;
     begin
     s := '';
     if (n > 0) and (n <= arrayused) then
          begin
          s := arrayptr^[n].fetch;
          end;
     fetchN := s;
     end;


Function  STRA_object.fetchString(n : integer) : string;
    begin
    fetchString := STRA_object.fetchN(n);
    end;


Function  STRA_object.fetchInteger(n : integer) : integer;
    begin
    fetchInteger := StrInt(STRA_object.fetchN(n));
    end;


Function  STRA_object.fetchLongInt(n : integer) : longint;
    begin
    fetchLongInt := StrLong(STRA_object.fetchN(n));
    end;


Function  STRA_object.fetchreal(n : integer) : real;
    begin
    fetchreal := StrReal(STRA_object.fetchN(n));
    end;


Function  STRA_object.fetchboolean(n : integer) : boolean;
var result : boolean;
    s      : string;
    begin
    result := false;
    s := UpCaseStr(STRA_object.fetchN(n));
    if      s = 'YES' then result := true
    else if s = 'TRUE' then result := true;
    fetchboolean := result;
    end;


Function STRA_object.LinearFind(st : string) : integer;
var n : integer;
    found : boolean;
    s     : string;
     begin
     n := 0;
     s := UpCaseStr(st);
     if (arrayused > 0) then
          begin
          found := false;
          while (n < arrayused) and not found do
               begin
               inc(n);
               if s = arrayptr^[n].fetch then found := true;
               end;
          end;
     if not found then n := 0;
     linearfind := n;
     end;



Function STRA_object.linearsearch(st : string; mode : byte) : integer;
var n : integer;
    found : boolean;
    s     : string;
     begin  {mode 0 = exact; 1 = GE; 2 = LE   assumes ascending sort}
     n := 0;
     s := UpCaseStr(st);
     if (arrayused > 0) then
          begin
          found := false;
          while (n < arrayused) and not found do
               begin
               inc(n);
               if (s = arrayptr^[n].fetch) then found := true
               else if (mode = 1) and (s < arrayptr^[n].fetch) then
                                   found := true
               else if (mode = 2) and (n < arrayused) then
                    begin
                    if (s > arrayptr^[n].fetch) and
                       (s < arrayptr^[n+1].fetch) then
                                   found := true;
                    end;
               end;
          end;
     if not found then n := 0;
     linearsearch := n;
     end;


Procedure STRA_object.dump;
var i  : integer;
     begin
     if arrayused < 1 then exit;
     for i := 1 to arrayused do
          begin
          writeln(i:4,' [',arrayptr^[i].fetch,']  ');
          end;
     writeln('');
     end;


Procedure STRA_object.listpage(f,n,w : integer);
var i  : integer;
     begin
     if (f > arrayused) or (arrayused < 1) then exit;
     i := f;
     if i < 1 then i := 1;
     while (i < (f+n)) do
          begin
          writeln(leftstr(arrayptr^[i].fetch,w-1));
          inc(i);
          end;
     end;


Procedure STRA_object.save(fname : string);
var i  : integer;
    OK : boolean;
    TEXTF : TFILE_object;
     begin
     if arrayused < 1 then exit;
     TEXTF.init(fname,true);
     for i := 1 to arrayused do
          begin
          ok := TEXTF.append(STRA_object.fetchN(i));
          end;
     TEXTF.done;
     end;


Procedure STRA_object.load(fname : string);
var s : string;
    OK : boolean;
    TEXTF : TFILE_object;
     begin
     TEXTF.init(fname,false);
     ok := TEXTF.opened;
     while ok do
          begin
          ok := TEXTF.fetchnext(s);
          if ok then ok := STRA_object.append(s);
          end;
     modified := false;
     TEXTF.done;
     end;


Procedure STRA_object.loadsection(fname,sectiontag,sectionname : string);
var secttag,sectname  : string[40];
    sectlen   : integer;
    ok, found : boolean;
    s         : string;
    TEXTF     : TFILE_object;
     begin
     found := false;
     secttag  := UpcaseStr(sectiontag);
     sectname := UpcaseStr(sectionname);
     trim(sectname);
     sectlen  := length(sectname);
     TEXTF.init(fname,false);
     ok := TEXTF.opened;
     while ok do
          begin
          ok := TEXTF.fetchnext(s);
          if ok then
               begin
               if secttag = leftstr(UpCaseStr(s),length(secttag)) then
                     begin
                     if found then
                          begin
                          found := false;
                          ok := false;
                          end
                     else begin
                          delete(s,1,length(secttag));
                          RemoveLeading(s,' ');
                          if leftstr(UpCaseStr(s),sectlen) = sectname then
                                found := true;
                          end;
                     end
               else if found then ok := STRA_object.append(s);
               end;
          end;
     modified := false;
     TEXTF.done;
     end;



{$R-}


Procedure STRA_object.swap(i,j : integer);
var sptr : stringptr;
     begin
     sptr := arrayptr^[i].strptr;
     arrayptr^[i].strptr := arrayptr^[j].strptr;
     arrayptr^[j].strptr := sptr;
     modified := true;
     end;


procedure STRA_object.sort;
var Gap,I,J,N : integer;
    s1,s2      : stringptr;
     begin
     if arraysorted then exit;
     N   := STRA_object.count;
     Gap := N div 2;
     while (Gap > 0) do
         begin
         I := Gap;
         while (I < N) do
              begin
              J := I - Gap;
              s1 := arrayptr^[J+Gap+1].strptr;
              s2 := arrayptr^[J+1].strptr;
              while (J >= 0) and (s1^ < s2^) do
                   begin
                   STRA_object.swap(J+1,J+Gap+1);
                   dec(J,Gap);
                   s1 := arrayptr^[J+Gap+1].strptr;
                   s2 := arrayptr^[J+1].strptr;
                   end;
              inc(I);
              end;
         Gap:=Gap div 2;
         end;
     modified := true;
     arraysorted := true;
     end;


{$R+}

Function STRA_object.binsearchEQ(st : string) : integer;  {exact match}
var i,n,p : integer;
    s1    : string;
     begin
     p := 0;
     n := arrayused;
     while (n > 1) do
          begin
          n := (n + 1) div 2;
          if st = arrayptr^[p+n].strptr^ then
               begin
               binsearchEQ := (p+n);
               exit;
               end
          else if st > arrayptr^[p+n].strptr^  then p := p + n;
          end;
     binsearchEQ := 0;
     end;


Function STRA_object.binsearchAPPROX(st : string) : integer;
                                                {first generic match}
var i,n,p : integer;
    s1    : string;
     begin
     p := 0;
     n := arrayused;
     while (n > 1) do
          begin
          n := (n + 1) div 2;
          if st = arrayptr^[p+n].strptr^ then
               begin
               binsearchAPPROX := (p+n);
               exit;
               end
          else if st > arrayptr^[p+n].strptr^  then p := p + n;
          end;
     if st = leftstr(arrayptr^[p+1].strptr^,length(st)) then
          binsearchAPPROX := p+1
     else binsearchAPPROX := 0;
     end;


Function STRA_object.BinSearchLE(st : string) : integer; {returns LE}
var i,n,p : integer;
    s1    : string;
     begin
     p := 0;
     n := arrayused;
     while (n > 1) do
          begin
          n := (n + 1) div 2;
          if st = arrayptr^[p+n].strptr^ then
               begin
               BinSearchLE := (p+n);
               exit;
               end
          else if st > arrayptr^[p+n].strptr^  then p := p + n;
          end;
     BinSearchLE := p;
     end;


Function STRA_object.BinSearchGE(st : string) : integer; {returns LE}
var i,n,p : integer;
    s1    : string;
     begin
     p := 0;
     n := arrayused;
     while (n > 1) do
          begin
          n := (n + 1) div 2;
          if st = arrayptr^[p+n].strptr^ then
               begin
               BinSearchGE := (p+n);
               exit;
               end
          else if st > arrayptr^[p+n].strptr^  then p := p + n;
          end;
     if p < arrayused then BinSearchGE := p+1
     else BinSearchGE := 0;
     end;


Function STRA_object.Find(st : string) : integer;
var n : integer;
     begin
     if arraysorted then n := STRA_object.binsearchEQ(st)
     else n := STRA_object.linearfind(st);
     Find := n;
     end;


Function STRA_object.Search(st : string; mode : byte) : integer;
var n : integer;
     begin
     n := 0;
     if arraysorted then
          begin
          case mode of
              0 : n := STRA_object.binsearchEQ(st);
              1 : n := STRA_object.binsearchGE(st);
              2 : n := STRA_object.binsearchLE(st);
              end;
          end
     else n := STRA_object.linearsearch(st,mode);
     Search := n;
     end;


Function  STRA_object.insertstr(n : integer;st : string):boolean;
{ append the item to the array, then bubble down to position }
var ok : boolean;
    i  : integer;
     begin
     ok := STRA_object.append(st);
     if ok then
          begin
          modified := true;
          if (n+1) < count then
               begin
               for i := count-1 downto n+1 do swap(i+1,i);
               end;
          end;
     insertstr := ok;
     end;


Function  STRA_object.deletestr(n : integer):boolean;

{ for now, just bubble the item to the end, replace with
    null string and decrement the count - this leaves some
    heap garbage which I will ignore for now }

var ok : boolean;
    i  : integer;
     begin
     if n <= count then
          begin
          if (n+1) < count then
               begin
               for i := n to count-1 do swap(i+1,i);
               end;
          ok := STRA_object.storeN(count,'');
          dec(arrayused);
          modified := true;
          end;
     deletestr := ok;
     end;